Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-04/ops5c.zip/WALTZ.OPS

Text File | 1988-12-09 | 12KB | 403 lines

                                                ;and the RHS actions that
                                                ;are user defined


;Our WM elements.  Lines have the lable line followed by the 2 points
;defining the line.  Edges are like lines accept that they can be labeled,
;permanently labelled and plotted.  Junctions are defined by 4 points.  The
;basepoint is where the 3 (2) lines intersect.  The points p1, p2, p3 are the
;other endpoints of the lines at this junction

(literalize stage value)
(literalize line p1 p2)
(literalize edge p1 p2 joined label plotted)
(literalize junction p1 p2 p3 base_point type)

;The Waltz Algorithm using OPS5 Production System Interpreter
;This is our production memory

;Our starting production.  It checks to see if the start flag is in WM,
;and if it is, it deletes it, and clears the screen
(p begin
    (stage ^value start)
    -->
;    (write clr)
    (make line ^p1 0122 ^p2 0107)
    (make line ^p1 0107 ^p2 2207)
    (make line ^p1 2207 ^p2 3204)
    (make line ^p1 3204 ^p2 6404)
    (make line ^p1 2216 ^p2 2207)
    (make line ^p1 3213 ^p2 3204)
    (make line ^p1 2216 ^p2 3213)
    (make line ^p1 0107 ^p2 2601)
    (make line ^p1 2601 ^p2 7401)
    (make line ^p1 6404 ^p2 7401)
    (make line ^p1 3213 ^p2 6413)
    (make line ^p1 6413 ^p2 6404)
    (make line ^p1 7416 ^p2 7401)
    (make line ^p1 5216 ^p2 6413)
    (make line ^p1 2216 ^p2 5216)
    (make line ^p1 0122 ^p2 5222)
    (make line ^p1 5222 ^p2 7416)
    (make line ^p1 5222 ^p2 5216)
    (modify 1 ^value duplicate))

;If the duplicate flag is set, and there is still a line in WM, delete the line
;and add two edges. One edge runs from p1 to p2 and the other runs from p2 to
;p1.  We then plot the edge.
(p reverse_edges
    (stage ^value duplicate)
    (line ^p1 <p1> ^p2 <p2>)
    -->
;    (write draw <p1> <p2> (crlf))
    (make edge ^p1 <p1> ^p2 <p2> ^joined false)
        (make edge ^p1 <p2> ^p2 <p1> ^joined false)
    (remove 2))

;If the duplicating flag is set, and there are no more lines, then remove the
;duplicating flag and set the make junctions flag.
(p done_reversing
    (stage ^value duplicate)
    - (line)
    -->
    (modify 1 ^value detect_junctions))


;If three edges meet at a point and none of them have already been joined in
;a junction, then make the corresponding type of junction and label the
;edges joined.  This production calls make-3_junction to determine
;what type of junction it is based on the angles inscribed by the
;intersecting edges
(p make-3_junction
    (stage ^value detect_junctions)
    (edge ^p1 <base_point> ^p2 <p1> ^joined false)
    (edge ^p1 <base_point> ^p2 {<p2> <> <p1>} ^joined false)
    (edge ^p1 <base_point> ^p2 {<p3> <> <p1> <> <p2>} ^joined false)
    -->
    (make junction
          ^type (make_3_junction <base_point> <p1> <p2> <p3>)
              ^base_point <base_point>)
    (modify 2 ^joined true)
    (modify 3 ^joined true)
    (modify 4 ^joined true))

;If two, and only two, edges meet that have not already been joined, then
;the junction is an "L"
(p make_L
    (stage ^value detect_junctions)
    (edge ^p1 <base_point> ^p2 <p2> ^joined false)
    (edge ^p1 <base_point> ^p2 {<p3> <> <p2>} ^joined false)
    - (edge ^p1 <base_point> ^p2 {<> <p2> <> <p3>})
    -->
    (make junction
        ^type L
        ^base_point <base_point>
        ^p1 <p2>
        ^p2 <p3>)
    (modify 2 ^joined true)
    (modify 3 ^joined true))


;If the detect junctions flag is set, and there are no more un_joined edges,
;set the find_initial_boundary flag
(p done_detecting
    (stage ^value detect_junctions)
    - (edge ^joined false)
    -->
    (modify 1 ^value find_initial_boundary))

;If the initial boundary junction is an L, then we know it's labelling
(p initial_boundary_junction_L
    (stage ^value find_initial_boundary)
        (junction ^type L ^base_point <base_point> ^p1 <p1> ^p2 <p2>)
    (edge ^p1 <base_point> ^p2 <p1>)
    (edge ^p1 <base_point> ^p2 <p2>)
        - (junction ^base_point > <base_point>)
    -->
        (modify 3 ^label B)
    (modify 4 ^label B)
    (modify 1 ^value find_second_boundary))

;Ditto for an arrow
(p initial_boundary_junction_arrow
    (stage ^value find_initial_boundary)
    (junction ^type arrow ^base_point <bp> ^p1 <p1> ^p2 <p2> ^p3 <p3>)
    (edge ^p1 <bp> ^p2 <p1>)
    (edge ^p1 <bp> ^p2 <p2>)
    (edge ^p1 <bp> ^p2 <p3>)
    - (junction ^base_point > <bp>)
    -->
    (modify 3 ^label B)
    (modify 4 ^label +)
    (modify 5 ^label B)
    (modify 1 ^value find_second_boundary))

;If we have already found the first boundary point, then find the second
;boundary point, and label it.

(p second_boundary_junction_L
    (stage ^value find_second_boundary)
        (junction ^type L ^base_point <base_point> ^p1 <p1> ^p2 <p2>)
    (edge ^p1 <base_point> ^p2 <p1>)
    (edge ^p1 <base_point> ^p2 <p2>)
        - (junction ^base_point < <base_point>)
    -->
        (modify 3 ^label B)
    (modify 4 ^label B)
    (modify 1 ^value labeling))

(p second_boundary_junction_arrow
    (stage ^value find_second_boundary)
    (junction ^type arrow ^base_point <bp> ^p1 <p1> ^p2 <p2> ^p3 <p3>)
    (edge ^p1 <bp> ^p2 <p1>)
    (edge ^p1 <bp> ^p2 <p2>)
    (edge ^p1 <bp> ^p2 <p3>)
    - (junction ^base_point < <bp>)
    -->
    (modify 3 ^label B)
    (modify 4 ^label +)
    (modify 5 ^label B)
    (modify 1 ^value labeling))


;If we have an edge whose label we already know definitely, then
;label the corresponding edge in the other direction
(p match_edge
    (stage ^value labeling)
    (edge ^p1 <p1> ^p2 <p2> ^label {<label> << + - B >>})
    (edge ^p1 <p2> ^p2 <p1> ^label nil)
    -->
    (modify 2 ^plotted t)
    (modify 3 ^label <label> ^plotted t)
;    (write plot <label> <p1> <p2> (crlf))
    )
;The following productions propogate the possible labellings of the edges
;based on the labellings of edges incident on adjacent junctions.  Since
;from the initial boundary productions, we have determined the labellings of
;of atleast two junctions, this propogation will label all of the junctions
;with the possible labellings.  The search space is pruned due to filtering,
;i.e. - only label a junction in the ways physically possible based on the
;labellings of adjacent junctions.


(p label_L
    (stage ^value labeling)
    (junction ^type L ^base_point <p1>)
    (edge ^p1 <p1> ^p2 <p2> ^label << + - >>)
    (edge ^p1 <p1> ^p2 <> <p2> ^label nil)
    -->
    (modify 4 ^label B))


(p label_tee_A
    (stage ^value labeling)
    (junction ^type tee ^base_point <bp> ^p1 <p1> ^p2 <p2> ^p3 <p3>)
    (edge ^p1 <bp> ^p2 <p1> ^label nil)
    (edge ^p1 <bp> ^p2 <p3>)
    -->
    (modify 3 ^label B)
    (modify 4 ^label B))


(p label_tee_B
    (stage ^value labeling)
    (junction ^type tee ^base_point <bp> ^p1 <p1> ^p2 <p2> ^p3 <p3>)
    (edge ^p1 <bp> ^p2 <p1>)
    (edge ^p1 <bp> ^p2 <p3> ^label nil)
    -->
    (modify 3 ^label B)
    (modify 4 ^label B))


(p label_fork-1
    (stage ^value labeling)
    (junction ^type fork ^base_point <bp>)
    (edge ^p1 <bp> ^p2 <p1> ^label +)
    (edge ^p1 <bp> ^p2 {<p2> <> <p1>} ^label nil)
    (edge ^p1 <bp> ^p2 {<> <p2> <> <p1>})
    -->
    (modify 4 ^label +)
    (modify 5 ^label +))


(p label_fork-2
    (stage ^value labeling)
    (junction ^type fork ^base_point <bp>)
    (edge ^p1 <bp> ^p2 <p1> ^label B)
    (edge ^p1 <bp> ^p2 {<p2> <> <p1>} ^label -)
    (edge ^p1 <bp> ^p2 {<> <p2> <> <p1>} ^label nil)
    -->
    (modify 5 ^label B))


(p label_fork-3
    (stage ^value labeling)
    (junction ^type fork ^base_point <bp>)
    (edge ^p1 <bp> ^p2 <p1> ^label B)
    (edge ^p1 <bp> ^p2 {<p2> <> <p1>} ^label B)
    (edge ^p1 <bp> ^p2 {<> <p2> <> <p1>} ^label nil)
    -->
    (modify 5 ^label -))


(p label_fork-4
    (stage ^value labeling)
    (junction ^type fork ^base_point <bp>)
    (edge ^p1 <bp> ^p2 <p1> ^label -)
    (edge ^p1 <bp> ^p2 {<p2> <> <p1>} ^label -)
    (edge ^p1 <bp> ^p2 {<> <p2> <> <p1>} ^label nil)
    -->
    (modify 5 ^label -))



(p label_arrow-1A
    (stage ^value labeling)
    (junction ^type arrow ^base_point <bp> ^p1 <p1> ^p2 <p2> ^p3 <p3>)
    (edge ^p1 <bp> ^p2 <p1> ^label {<label> << B - >>})
    (edge ^p1 <bp> ^p2 <p2> ^label nil)
    (edge ^p1 <bp> ^p2 <p3>)
    -->
    (modify 4 ^label +)
    (modify 5 ^label <label>))


(p label_arrow-1B
    (stage ^value labeling)
    (junction ^type arrow ^base_point <bp> ^p1 <p1> ^p2 <p2> ^p3 <p3>)
    (edge ^p1 <bp> ^p2 <p1> ^label {<label> << B - >>})
    (edge ^p1 <bp> ^p2 <p2>)
    (edge ^p1 <bp> ^p2 <p3> ^label nil)
    -->
    (modify 4 ^label +)
    (modify 5 ^label <label>))


(p label_arrow-2A
    (stage ^value labeling)
    (junction ^type arrow ^base_point <bp> ^p1 <p1> ^p2 <p2> ^p3 <p3>)
    (edge ^p1 <bp> ^p2 <p3> ^label {<label> << B - >>})
    (edge ^p1 <bp> ^p2 <p2> ^label nil)
    (edge ^p1 <bp> ^p2 <p1>)
    -->
    (modify 4 ^label +)
    (modify 5 ^label <label>))

(p label_arrow-2B
    (stage ^value labeling)
    (junction ^type arrow ^base_point <bp> ^p1 <p1> ^p2 <p2> ^p3 <p3>)
    (edge ^p1 <bp> ^p2 <p3> ^label {<label> << B - >>})
    (edge ^p1 <bp> ^p2 <p2>)
    (edge ^p1 <bp> ^p2 <p1> ^label nil)
    -->
    (modify 4 ^label +)
    (modify 5 ^label <label>))


(p label_arrow-3A
    (stage ^value labeling)
    (junction ^type arrow ^base_point <bp> ^p1 <p1> ^p2 <p2> ^p3 <p3>)
    (edge ^p1 <bp> ^p2 <p1> ^label +)
    (edge ^p1 <bp> ^p2 <p2> ^label nil)
    (edge ^p1 <bp> ^p2 <p3>)
    -->
    (modify 4 ^label -)
    (modify 5 ^label +))

(p label_arrow-3B
    (stage ^value labeling)
    (junction ^type arrow ^base_point <bp> ^p1 <p1> ^p2 <p2> ^p3 <p3>)
    (edge ^p1 <bp> ^p2 <p1> ^label +)
    (edge ^p1 <bp> ^p2 <p2>)
    (edge ^p1 <bp> ^p2 <p3> ^label nil)
    -->
    (modify 4 ^label -)
    (modify 5 ^label +))


(p label_arrow-4A
    (stage ^value labeling)
    (junction ^type arrow ^base_point <bp> ^p1 <p1> ^p2 <p2> ^p3 <p3>)
    (edge ^p1 <bp> ^p2 <p3> ^label +)
    (edge ^p1 <bp> ^p2 <p2> ^label nil)
    (edge ^p1 <bp> ^p2 <p1>)
    -->
    (modify 4 ^label -)
    (modify 5 ^label +))

(p label_arrow-4B
    (stage ^value labeling)
    (junction ^type arrow ^base_point <bp> ^p1 <p1> ^p2 <p2> ^p3 <p3>)
    (edge ^p1 <bp> ^p2 <p3> ^label +)
    (edge ^p1 <bp> ^p2 <p2>)
    (edge ^p1 <bp> ^p2 <p1> ^label nil)
    -->
    (modify 4 ^label -)
    (modify 5 ^label +))


(p label_arrow-5A
    (stage ^value labeling)
    (junction ^type arrow ^base_point <bp> ^p1 <p1> ^p2 <p2> ^p3 <p3>)
    (edge ^p1 <bp> ^p2 <p2> ^label -)
    (edge ^p1 <bp> ^p2 <p1>)
    (edge ^p1 <bp> ^p2 <p3> ^label nil)
    -->
    (modify 4 ^label +)
    (modify 5 ^label +))


(p label_arrow-5B
    (stage ^value labeling)
    (junction ^type arrow ^base_point <bp> ^p1 <p1> ^p2 <p2> ^p3 <p3>)
    (edge ^p1 <bp> ^p2 <p2> ^label -)
    (edge ^p1 <bp> ^p2 <p1> ^label nil)
    (edge ^p1 <bp> ^p2 <p3>)
    -->
    (modify 4 ^label +)
    (modify 5 ^label +))


;The conflict resolution mechanism will onle execute a production if no
;productions that are more complicated are satisfied.  This production is
;simple, so all of the above dictionary productions will fire before this
;change of state production
(p done_labeling
    (stage ^value labeling)
    -->
    (modify 1 ^value plot_remaining_edges))

;At this point, some labellings may have not been plotted, so plot them
(p plot_remaining
    (stage ^value plot_remaining_edges)
    (edge ^plotted nil ^label {<label> <> nil} ^p1 <p1> ^p2 <p2>)
    -->
;    (write plot <label> <p1> <p2> (crlf))
    (modify 2 ^plotted t))


;If we have been un able to label an edge, assume that it is a boundary.
;This is a total Kludge, but what the hell. (if we assume only valid drawings
;will be given for labeling, this assumption generally is true!)
(p plot_boundaries
    (stage ^value plot_remaining_edges)
    (edge ^plotted nil ^label nil ^p1 <p1> ^p2 <p2>)
    -->
;    (write plot B <p1> <p2> (crlf))
    (modify 2 ^plotted t))

;If there is no more work to do, then we are done and flag it.
(p done_plotting
    (stage ^value plot_remaining_edges)
    - (edge ^plotted nil)
    -->
    (modify 1 ^value done))

;Prompt the user as to where he can see a trace of the OPS5
;execution
(p done
    (stage ^value done)
    -->
;    (write see trace.waltz for description of execution- hit CR to end (crlf))
    (halt))